{- «•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»

    Copyright © 2011 - 2021, Ingo Wechsung
    All rights reserved.

    Redistribution and use in source and binary forms, with or
    without modification, are permitted provided that the following
    conditions are met:

        Redistributions of source code must retain the above copyright
        notice, this list of conditions and the following disclaimer.

        Redistributions in binary form must reproduce the above
        copyright notice, this list of conditions and the following
        disclaimer in the documentation and/or other materials provided
        with the distribution. Neither the name of the copyright holder
        nor the names of its contributors may be used to endorse or
        promote products derived from this software without specific
        prior written permission.

    THIS SOFTWARE IS PROVIDED BY THE
    COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
    IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER
    OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
    USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
    AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
    IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
    THE POSSIBILITY OF SUCH DAMAGE.

    «•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•» -}

{--
 * 'IO' actions and native types concerning class loading and annotation
 *
 * All java interface types used for annotations are declared here
 * under the name of the compiler type they are transformed to during import.
 * For example 'QName' is the frege representation of the
 * java annotation interface "frege.runtime.Meta.QName" and
 * import will build a 'frege.compiler.types.QNames#QName' from it.
 *
 * There is only one top level annotation 'FregePackage'.
 * It is loaded with the 'getFrege' function
 * which is implemented in "frege.runtime.CompilerSupport".
 *
 * While writing this boring code, I was really keen to first implement an "import native class"
 * language feature. But it had to be done in the version 2 first, and the code was decidedly
 * fixed.
 -}

module frege.compiler.Classtools where

import Java.Net public (URL, URLArray, URLClassLoader, URI)



{--
 * make a URL class loader from a list of strings
 -}
makeClassLoader pathelems  = do
        urls <- mapM toURL pathelems
        urlarr <- JArray.genericFromList urls
        ClassLoader.current >>= URLClassLoader.new urlarr
    where 
        toURL :: String -> ST s URL
        toURL str = do
            let f = File.new str
                u = File.toURI f
            case u.toURL of
              Right url -> return url
              Left exc  -> throwST exc


type ExMb a = (ClassNotFoundException | (Maybe a))

{--
    This data structure helps to find already generated function pointers.

    see @frege.runtime.Meta.FunctionPointers@
--}
data FunctionPointers = pure native frege.runtime.Meta.FunctionPointers where
    {-- The list of java class names associated with the element from 'LambdaClasses.qnames'
        with the same index. -}
    pure native jnames      :: FunctionPointers -> JArray String
    {-- The list of function names who have already a static Lambda Class. -}
    pure native qnames      :: FunctionPointers -> QNameArr

native getFunctions frege.runtime.CompilerSupport.getFunctions
        :: MutableIO URLClassLoader -> String -> IO (Maybe FunctionPointers)
            throws ClassNotFoundException

{--
    FregePackage - the serialized symbol table of an imported package
 -}
data FregePackage = pure native frege.runtime.Meta.FregePackage where
    pure native source      :: FregePackage -> String
    --- last compilation time
    pure native time        :: FregePackage -> Long
    pure native jmajor      :: FregePackage -> Int
    pure native jminor      :: FregePackage -> Int
    pure native doc         :: FregePackage -> String
    pure native imps        :: FregePackage -> JArray String
    pure native nmss        :: FregePackage -> JArray String
    pure native symas       :: FregePackage -> SymAArr
    pure native symcs       :: FregePackage -> SymCArr
    pure native symis       :: FregePackage -> SymIArr
    pure native symts       :: FregePackage -> SymTArr
    pure native symvs       :: FregePackage -> SymVArr
    pure native symls       :: FregePackage -> SymLArr
    pure native taus        :: FregePackage -> TauArr
    pure native rhos        :: FregePackage -> RhoArr
    pure native sigmas      :: FregePackage -> SigmaArr
    pure native exprs       :: FregePackage -> ExprArr


native getFrege frege.runtime.CompilerSupport.getFrege
                            :: MutableIO ClassLoader -> String -> IO (Maybe FregePackage)
                            throws ClassNotFoundException



--- 'QName' annotation

data QName = pure native frege.runtime.Meta.QName where
    pure native kind   :: QName -> Int     -- constructor TName, VName or MName
    pure native pack   :: QName -> String  -- package name
    pure native base   :: QName -> String  -- base name
    pure native member :: QName -> String  -- member name, only valid when kind=2

derive ArrayElement QName
type QNameArr = JArray QName

-- noQName ∷ QNameArr
-- noQName = ST.run ((newArray 0 :: ST s (ArrayOf s QName)) >>= readonly id)

--- 'Expr' annotation

data Expr = pure native frege.runtime.Meta.Expr where
    pure native xkind  :: Expr -> Int        -- Ann, App, Case, Con, Ifte, Lam, Lit, local/global Var
    pure native name   :: Expr -> QNameArr   -- global Vbl, Con
    pure native lkind  :: Expr -> Int        -- Ann : sigma index, Lit: ord literalkind, Case: ord ckind
    pure native varval :: Expr -> String     -- Lit : value, local Vbl: name
    pure native alts   :: Expr -> JArray Int -- Case, Lambda: pattern and expression indexes
    pure native subx1  :: Expr -> Int        -- Ann, App, Ifte, Case: first subexpression
    pure native subx2  :: Expr -> Int        -- App, Ifte: second subexpression
    pure native subx3  :: Expr -> Int        -- Ifte: third subexpression

derive ArrayElement Expr
type ExprArr = JArray Expr

{--
    A Tau type in annotational representation.
    There is no recursion, 'Int' indices point to some table where subtypes are stored.
 
    See also "frege/runtime/Meta.java"
 
    This is also used for Kinds.
 -}
data Tau = pure native frege.runtime.Meta.Tau where
    pure native kind :: Tau -> Int       --  constructor TApp, TFun, TCon, TVar
    pure native tcon :: Tau -> QNameArr  --  0 or 1 QNames
    pure native suba :: Tau -> Int       --  index of sub type a for TAPP or TFun
    pure native subb :: Tau -> Int       --  index of sub type b for TAPP or TFun
    pure native tvar :: Tau -> String    --  variable name for TVar

derive ArrayElement Tau
type TauArr = JArray Tau


--- 'Context' annotation

data Context = pure native frege.runtime.Meta.Context where
    pure native clas    :: Context -> QName     -- class name
    pure native tau     :: Context -> Int       -- tau index

type ContextArr = JArray Context


--- 'Rho' annotation

data Rho = pure native frege.runtime.Meta.Rho where
    pure native rhofun :: Rho -> Bool       -- tells if this is a RhoFun or a RhoTau
    pure native cont   :: Rho -> ContextArr -- the context
    pure native sigma  :: Rho -> Int        -- sigma index
    pure native rhotau :: Rho -> Int        -- if rhofun then rho index else tau index

derive ArrayElement Rho
type RhoArr = JArray Rho


--- 'Sigma' annotation

data Sigma = pure native frege.runtime.Meta.Sigma where
    pure native bound   :: Sigma -> JArray String   -- bound variables
    pure native kinds   :: Sigma -> JArray Int      -- and their kind indexes
    pure native rho     :: Sigma -> Int             -- rho index

derive ArrayElement Sigma
type SigmaArr = JArray Sigma


--- annotated type alias symbols

data SymA = pure native frege.runtime.Meta.SymA where
    pure native name    :: SymA -> QName        -- symbol name
    pure native doc     :: SymA -> String       -- symbol documentation
    pure native typ     :: SymA -> Int          -- sigma index
    pure native vars    :: SymA -> JArray Int   -- array of tau indexes
    pure native publik  :: SymA -> Bool         -- should this be imported by default?
    pure native offset  :: SymA -> Int          -- where definition begins, will be used in eclipse
    pure native kind    :: SymA -> Int          -- kind index

derive ArrayElement SymA
type SymAArr = JArray SymA


--- annotated link symbols

data SymL = pure native frege.runtime.Meta.SymL where
    pure native name    :: SymL -> QName        -- symbol name
    -- pure native doc     :: SymL -> String       -- symbol documentation
    pure native alias   :: SymL -> QName        -- symbol name of linked item
    pure native publik  :: SymL -> Bool         -- should this be imported by default?
    pure native offset  :: SymL -> Int          -- where definition begins, will be used in eclipse

derive ArrayElement SymL
type SymLArr = JArray SymL


--- annotated variable symbols

data SymV = pure native frege.runtime.Meta.SymV where
    pure native name    :: SymV -> QName        -- symbol name
    pure native doc     :: SymV -> String       -- symbol documentation
    pure native sig     :: SymV -> Int          -- sigma index
    pure native nativ   :: SymV -> String       -- native name if any
    pure native pur     :: SymV -> Bool
    pure native abst    :: SymV -> Bool
    pure native stri    :: SymV -> String       -- strictness encoded
    pure native depth   :: SymV -> Int          -- lambda depth
    pure native rkind   :: SymV -> Int          -- how do r- and w- functions return?
    pure native expr    :: SymV -> Int          -- expression index, valid if > 0
    pure native publik  :: SymV -> Bool         -- should this be imported by default?
    pure native offset  :: SymV -> Int          -- where definition begins, will be used in eclipse
    pure native throwing:: SymV -> JArray Int   -- list of Tau types that can be thrown
    pure native over    :: SymV -> QNameArr     -- list of members this one overloads
    pure native op      :: SymV -> Int          -- operator assoc and prec
    pure native gargs   :: SymV -> JArray Int   -- generic arguments tau indexes

derive ArrayElement SymV
type SymVArr = JArray SymV


--- annotated fields

data Field = pure native frege.runtime.Meta.Field where
    pure native offset  :: Field -> Int
    pure native name    :: Field -> String      -- field name or ""
    pure native doc     :: Field -> String      -- field doc or ""
    pure native privat  :: Field -> Bool        -- whether it is private
    pure native strict  :: Field -> Bool        -- whether it is strict
    pure native sigma   :: Field -> Int         -- sigma index of field type
    
derive ArrayElement Field
type FieldArr = JArray Field


--- annotated constructor symbols

data SymD = pure native frege.runtime.Meta.SymD where
    pure native name    :: SymD -> QName        -- symbol name
    pure native doc     :: SymD -> String       -- symbol documentation
    pure native cid     :: SymD -> Int          -- constructor number
    pure native typ     :: SymD -> Int          -- sigma index
    pure native fields  :: SymD -> FieldArr     -- array of fields
    pure native priv    :: SymD -> Bool         -- if constructor is private
    pure native publik  :: SymD -> Bool         -- should this be imported by default?
    pure native offset  :: SymD -> Int          -- where definition begins, will be used in eclipse
    pure native op      :: SymD -> Int          -- operator assoc and prec

derive ArrayElement SymD
type SymDArr = JArray SymD


--- annotated type class symbols

data SymC = pure native frege.runtime.Meta.SymC where
    pure native name    :: SymC -> QName        -- symbol name
    pure native doc     :: SymC -> String       -- symbol documentation
    pure native tau     :: SymC -> Int          -- tau index
    pure native sups    :: SymC -> QNameArr     -- array of super class names
    pure native ins1    :: SymC -> QNameArr     -- array of instantiated type names
    pure native ins2    :: SymC -> QNameArr     -- array of instance names
    pure native lnks    :: SymC -> SymLArr      -- links in the sub symtab
    pure native funs    :: SymC -> SymVArr      -- functions in the sub symtab
    pure native publik  :: SymC -> Bool         -- should this be imported by default?
    pure native offset  :: SymC -> Int          -- where definition begins, will be used in eclipse

derive ArrayElement SymC
type SymCArr = JArray SymC


--- annotated instance symbols

data SymI = pure native frege.runtime.Meta.SymI where
    pure native name    :: SymI -> QName        -- symbol name
    pure native doc     :: SymI -> String       -- symbol documentation
    pure native clas    :: SymI -> QName        -- class name
    pure native typ     :: SymI -> Int          -- sigma index
    pure native lnks    :: SymI -> SymLArr      -- links in the sub symtab
    pure native funs    :: SymI -> SymVArr      -- functions in the sub symtab
    -- pure native publik  :: SymI -> Bool         -- should this be imported by default?
    pure native offset  :: SymI -> Int          -- where definition begins, will be used in eclipse

derive ArrayElement SymI
type SymIArr = JArray SymI


--- annotated type symbols

data SymT = pure native frege.runtime.Meta.SymT where
    pure native name    :: SymT -> QName        -- symbol name
    pure native doc     :: SymT -> String       -- symbol documentation
    pure native typ     :: SymT -> Int          -- sigma index
    pure native gargs   :: SymT -> JArray Int   -- generic arguments tau indexes
    pure native cons    :: SymT -> SymDArr      -- data constructors
    pure native lnks    :: SymT -> SymLArr      -- links in the sub symtab
    pure native funs    :: SymT -> SymVArr      -- functions in the sub symtab
    pure native nativ   :: SymT -> String       -- native type if any
    pure native kind    :: SymT -> Int          -- kind index
    pure native prod    :: SymT -> Bool         -- if this is a product type
    pure native isEnum  :: SymT -> Bool         -- if this is an enum type
    pure native pur     :: SymT -> Bool         -- is it immutable nativ
    pure native newt    :: SymT -> Bool         -- is it a type with 1 constructor that has 1 field
    pure native publik  :: SymT -> Bool         -- should this be imported by default?
    pure native offset  :: SymT -> Int          -- where definition begins, will be used in eclipse

derive ArrayElement SymT
type SymTArr = JArray SymT
